home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / DATABASE / PKV4.ZIP;1 / MISC.PRG < prev    next >
Encoding:
Text File  |  1993-02-05  |  6.7 KB  |  202 lines
  1. /*⁄ƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒø
  2.  ›≥                                                                      ≥
  3.  ›≥ Program Name: MISC.PRG          Copyright: Gallagher Computing Corp. ≥
  4.  ›≥ Date Created: 02/04/93           Language: Clipper 5.0               ≥
  5.  ›≥ Time Created: 18:11:18             Author: Kevin S Gallagher         ≥
  6.  ›≥ c:/brief/clipper.src                                                 ≥
  7.  ›¿ƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒƒŸ
  8.  flflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflflfl           */
  9.  
  10.  
  11. #include "include1.ch"
  12.  
  13. FUNCTION Ratio( nOriginal, nPacked )
  14. RETURN ( STR( 100 - INT( ( nPacked / nOriginal ) * 100 ), 3, 0 ) + "% " )
  15.  
  16. FUNCTION FileType( nFileType )
  17.     LOCAL cFileType
  18.     DO CASE
  19.     CASE nFileType EQ 9                       ;    cFileType := " Squashed "
  20.     CASE nFileType EQ 8                       ;    cFileType := " Deflated "
  21.     CASE nFileType EQ 6                       ;    cFileType := " Implode  "
  22.     CASE nFileType EQ 3                       ;    cFileType := " Packed   "
  23.     CASE nFileType EQ 1                       ;    cFileType := " Shrunk   "
  24.     CASE nFileType EQ 0 .OR. nFileType EQ 2   ;    cFileType := " Stored   "
  25.     ENDCASE
  26. RETURN cFileType
  27.  
  28. FUNCTION SkipArray( nMove, nArrPos, nArrayLength )
  29.     IF nMove > 0
  30.         IF ( nArrPos + nMove ) >  nArrayLength
  31.             nMove := nArrayLength - nArrPos
  32.         ENDIF
  33.     ELSE
  34.         IF ( nArrPos + nMove ) < 1
  35.             nMove := 1 - nArrPos
  36.         ENDIF
  37.     ENDIF
  38.     nArrPos += nMove
  39. RETURN nMove
  40.  
  41. FUNCTION CALCDATE( nYearMon, nMonDay )
  42.     LOCAL nMonth, nYearInt
  43.     nYearInt:=IF(nYearMon > 39,( ( nYearMon-40 )/ 2 ),( ( nYearMon/2 )+80 ) )
  44.     nMonth  :=INT( ( nMonDay - 1 ) / 32 )
  45.     IF ( nYearMon % 2 ) = 1
  46.         nMonth += 8
  47.     ENDIF
  48. RETURN CTOD( PadNumL( nMonth ) + "/" +                                      ;
  49.     PadNumL( INT( ( ( nMonDay - 1 ) % 32 ) + 1 ) ) + "/" +                  ;
  50.     PadNumL( INT( nYearInt ) ) )
  51.  
  52. FUNCTION CALCTIME( nMinutes, nHourMin )
  53.     LOCAL nHour
  54.     nHour := INT( nHourMin / 8 )
  55.     nMinutes /= 32
  56.     nMinutes += ( nHourMin - ( nHour * 8 ) ) * 8
  57. RETURN ( PadNumL( nHour ) + ":" + PadNumL( INT( nMinutes ) ) )
  58.  
  59.  
  60. FUNCTION PadNumL( nNum )
  61. RETURN PADL( LTRIM( STR( nNum ) ), 2, "0" )
  62.  
  63. FUNCTION GetColObject( b )
  64. RETURN ( b:GETCOLUMN( b:COLPOS ) )
  65.  
  66. FUNCTION IsInPath(cFile)
  67.     local cPath  := GETENV("PATH") + [;], RetVal := []
  68.     local nMarker:= AT(";", cPath)
  69.     WHILE nMarker > 0
  70.         RetVal := substr(cPath, 1, nMarker - 1)
  71.         RetVal := RetVal + IF( RIGHT(RetVal, 1) != "\","\","")
  72.         IF FILE(RetVal + cFile)
  73.             exit
  74.         ELSE
  75.             nMarker := AT(";", cPath := substr(cPath, nMarker + 1) )
  76.             RetVal := []
  77.         ENDIF
  78.     ENDDO
  79. return RetVal
  80.  
  81. FUNCTION ZoomBox( bTR, bTC, bBR, bBC, cClrs, nDelay, lShad )
  82.     local cDefCol, xx, bBCx, bTCx, bBRx, bTRx, savecur := SETCURSOR(0)
  83.  
  84.     DEFAULT bTR    TO  0
  85.     DEFAULT bTC    TO  0
  86.     DEFAULT bBR    TO 24
  87.     DEFAULT bBC    TO 79
  88.     DEFAULT nDelay TO  0
  89.  
  90.     bBCx    := bTCx := ( INT( ( bBC - bTC + 1 ) / 2 ) + bTC )
  91.     bBRx    := bTRx := ( INT( ( bBR - bTR + 1 ) / 2 ) + bTR )
  92.     cDefCol := SETCOLOR( cClrs )
  93.     nDelay  := IF(valtype(nDelay) = "N",nDelay *=10,0)
  94.     nDelay  := IF(nDelay >= 1001,1000,nDelay)
  95.     lShad   := IF(empty(lShad), FALSE,lShad)
  96.  
  97.     WHILE TRUE
  98.         FOR xx = 1 TO nDelay
  99.         NEXT
  100.  
  101.         SETCOLOR( 'n+/n' )
  102.         DISPBEGIN()
  103.            SETCOLOR( cClrs )
  104.            @bTRx, bTCx CLEAR TO bBRx, bBCx
  105.            @bTRx, bTCx TO bBRx, bBCx DOUBLE
  106.            if(valtype(lShad) = "L",SHADOW(bTRx,bTCx,bBRx,bBCx,7),NIL)
  107.         DISPEND()
  108.       
  109.         IF bTRx EQ bTR AND bTCx EQ bTC AND bBRx EQ bBR AND bBCx EQ bBC
  110.             EXIT
  111.         ENDIF
  112.  
  113.         bTRx -= IF( bTRx EQ bTR, 0, 1 )
  114.         bTCx -= IF( bTCx EQ bTC, 0, 1 )
  115.         bBRx += IF( bBRx EQ bBR, 0, 1 )
  116.         bBCx += IF( bBCx EQ bBC, 0, 1 )
  117.     ENDDO
  118.     SETCOLOR( cDefCol )
  119.     SETCURSOR( savecur )
  120. return nil
  121.  
  122. //ƒƒƒƒƒƒ use List.com to look at the files contents
  123. FUNCTION ViewIt( cFilename, cWhichFile )
  124.     local SaveFullScreen()
  125.     IF !SWPRUNCMD("PKUNZIP -c "+cWhichFile+" "+cFileName+" | "+"LIST /s",0)
  126.         tone(100,1)
  127.     ENDIF
  128.     RestFullScreen()
  129. return nil
  130.  
  131. //ƒƒƒƒƒƒ use Blinker 2.xx and PkUnZip to extract file to disk
  132. FUNCTION Decomp(cFilename,cWhichFile)
  133.     local nChoice:=0,SaveFullScreen(),oldcolor:= setcolor("w/n")
  134.     local xInfo:={}, cInfo:="", cChkErr:=""
  135.     /*
  136.     * see if file exist and request confirmation to overwrite with the
  137.     * PkZip option "-o" to overwrite and not request confirmation to do so.
  138.     */
  139.     IF FILE(cFilename)
  140.         tone(100,5)
  141.         xInfo:=DIRECTORY(cFileName)
  142.         @ MR,0 say PADC(" FILENAME: "+ cFilename        + "      " + ;
  143.                      "CURRENT DATE: "+ DTOC(xInfo[1,3]) + "      " + ;
  144.                      "CURRENT TIME: "+ xInfo[1,4]       ,80) color "W+/R"
  145.         nChoice:= alert(cFileName+" exist overwrite it?",{" No "," Yes "} )
  146.         IF nChoice EQ 2
  147.             scroll()
  148.             IF !SWPRUNCMD("PKUNZIP -o "+cWhichFile+" "+cFileName,0,"","")
  149.                 alert("This is were to handle an error")
  150.             ENDIF
  151.         ELSE
  152.             alert("Aborting decompression")
  153.         ENDIF
  154.     ELSE
  155.         scroll()
  156.         IF !SWPRUNCMD("PKUNZIP "+cWhichFile+" "+cFileName,0,"","")
  157.             alert("This is were to handle an error")
  158.         ENDIF
  159.     ENDIF
  160.     cChkErr:=ZipTest( SWPERRLEV() )
  161.     RestFullScreen()
  162.     setcolor( oldcolor )
  163.     if LEN(cChkErr) <> 0
  164.         alert( cChkErr )
  165.     endif
  166. return nil
  167.  
  168. Procedure Shadow( nTr, nTc, nBr, nBc,nColor )
  169.     DEFAULT nColor TO 7
  170.     ShadowStrip( nBr+1, nTc+1, nBr+1, nBc+1,nColor )
  171.     ShadowStrip( nTr+1, nBc+1, nBr+1, nBc+1,nColor )
  172. Return
  173. Procedure TMARKER( nTr, nTc, nBr, nBc,nColor )
  174.     ShadowStrip( nBr, nTc, nBr, nBc,nColor )
  175.     ShadowStrip( nTr, nBc, nBr, nBc,nColor )
  176. Return
  177. STATIC Procedure ShadowStrip( nTr, nTc, nBr, nBc,nColor )
  178.     local cStrip    := SAVESCREEN( nTr, nTc, nBr, nBc )
  179.     local cTemplate := REPLICATE( 'x' +chr(nColor), LEN(cStrip) /2 )
  180.     cStrip          := TRANSFORM( cStrip, cTemplate )
  181.     RESTSCREEN( nTr, nTc, nBr, nBc, cStrip )
  182. Return
  183.  
  184. function WKEY(nDelay)
  185.     local nKey, cblock
  186.     DO CASE
  187.         CASE pcount() == 0
  188.             nKey := inkey()
  189.         CASE nDelay == NIL .AND. Pcount() == 1
  190.             nKey := inkey(0)
  191.         OTHERWISE
  192.             nKey := inkey(nDelay)
  193.     ENDCASE
  194.  
  195.     cblock := setkey(nKey)
  196.     IF cblock != NIL
  197.         eval(cblock, Procname(1), Procline(1), NIL)
  198.     ENDIF
  199. RETURN nKey
  200.  
  201.  
  202.